library(data.table)
library(stringi)
library(dplyr)
library(stringr)
library(text2vec)
library(readxl)
library(Matrix)
library(text2vec)
library(rdrop2)
library(ggplot2)
library(plotly)
library(magrittr)
library(stringdist)
library(xgboost)
# GESTION DE LA CONVERSION DES NOMBRES EN CHAINE DE CARACTERES SANS UTILISER LA NOTATION SCIENTIFIQUE
# https://stackoverflow.com/questions/5352099/how-to-disable-scientific-notation
options("scipen"=100, "digits"=10) 

Préparation des données

Base des indicateurs

Aperçu

data2 <- fread("data/29032018_Index2.csv",encoding="Latin-1")
nb_indicateurs=nrow(data2)

Le jeu de données contient indicateurs.

Les données sont principalement textuelles, certaines peut-être plus exploitables que d’autres.

names(data2)
##  [1] "index"                                             
##  [2] "Base"                                              
##  [3] "Indicateur"                                        
##  [4] "Famille"                                           
##  [5] "Famille Finale_DREES"                              
##  [6] "Classement producteur Niveau 3 (le plus détaillé)" 
##  [7] "Classement producteur Niveau 2"                    
##  [8] "Classement producteur Niveau 1 (le moins détaillé)"
##  [9] "thème_DREES"                                       
## [10] "Domaine 1_DREES"                                   
## [11] "Domaine 2_DREES"                                   
## [12] "Domaine 3_DREES"                                   
## [13] "Source"                                            
## [14] "Producteur"                                        
## [15] "Echelle géo. nationale"                            
## [16] "Echelle géo. Rég"                                  
## [17] "Echelle géo dep"                                   
## [18] "Autre échelle de restitution"                      
## [19] "Profondeur historique"                             
## [20] "Fréquence d'actualisation"                         
## [21] "Commentaires"                                      
## [22] "Base"                                              
## [23] "Date version base"                                 
## [24] "Type d'accès"                                      
## [25] "Accéder à la base"                                 
## [26] "Producteur de la base"                             
## [27] "index"
head(data2,2)#Un View(head(data2,100)) sera peut-être plus approprié pour vous.

Variables doublons

La variable index est présente deux fois !

On vérifie que c’est bien les mêmes valeurs les deux fois puis on supprime

data2[c(!data2[,1]==data2[,27]),c(1,27)]
data2[,27] <- NULL

La variable Base est présente deux fois !

Même procédure, on observe des différences mais c’est seulement des problèmes de majuscules.

head(data2[c(!data2[,2]==data2[,22]),c(2,22)])
data2[c(!tolower(data2[,2])==tolower(data2[,22])),c(2,22)]
data2[,22] <- NULL

En particulier certaines méritent peut-être un pré-traitement, par exemple les noms des producteurs INSEE, DREES, CNAMTS écrit en plein texte.

head(sample(data2$Producteur))
## [1] "Caisse Nationale de l'Assurance Maladie des Travailleurs Salariés (CNAMTS)"                                                                             
## [2] "Agence technique de l'information sur l'hospitalisation (ATIH)"                                                                                         
## [3] "Institut national de la statistique et des études économiques (Insee)"                                                                                  
## [4] "Agence régionale de santé (ARS)"                                                                                                                        
## [5] "Agence technique de l'information sur l'hospitalisation (ATIH)"                                                                                         
## [6] "Direction de la recherche des études de l’évaluation et des statistiques (DREES), Institut national de la statistique et des études économiques (Insee)"

Traitement des acronymes avec des expressions régulières

Commençons par une expression régulière pour récupérer le texte entre parenthèses (acronyme)

data2$producteur_acronyme=data2$Producteur%>%
  stri_extract_all(regex = "(\\()([A-z]+)(\\))")%>%#On récupère LES chaînes de caractères entre parenthèses
  lapply(function(x)paste(x,collapse=" "))%>%# On les colle
  unlist%>%gsub(pattern = '(\\()|(\\))',replacement = '') # On met en vecteur et on supprime les parenthèses
data2[producteur_acronyme=="NA",producteur_acronyme:=Producteur]#On gère les noms sans acronyme
table(data2$producteur_acronyme)%>%head
## 
##                 Agence de l'eau        Air Paca           ANMDA 
##             153               3               8               1 
##            ANSM             ARS 
##               1             254

Même idée pour la source

data2$source_acronyme=data2$Source%>%
  stri_extract_all(regex = "(\\()([A-z]+)(\\))")%>%#On récupère LES chaînes de caractères entre parenthèses
  lapply(function(x)paste(x,collapse=" "))%>%# On les colle
  unlist%>%gsub(pattern = '(\\()|(\\))',replacement = '') # On met en vecteur et on supprime les parenthèses
data2[source_acronyme=="NA",source_acronyme:=Source]#On gère les noms sans acronyme
table(data2$source_acronyme)%>%head
## 
##                             Accidents de la circulation 
##                        2283                           3 
##                       Adeli                  Adeli RPPS 
##                           9                          13 
##                       AGATA                         ALD 
##                           3                          82

Suppression des stop-words

Pour remplacer plusieurs mots d’un coup, stringr propose une fonction polymorphe très pratique str_replace_all. Lorsqu’on fournit un vecteur nommé à la place des paramètres pattern et replacement, la fonction est appliquée au vecteur de sorte que pour chaque entrée du vecteur, le nom joue le rôle de pattern et la valeur joue le rôle de replacement.

On commence par construire notre liste de stopwords.

stop_words = tm::stopwords(kind="fr")
# stop_words=c(stop_words,"actifs part entière APE")
stop_words=paste0(" ",stop_words," ")
stop_words=c(stop_words," c'"," l'"," d'"," j'"," t'"," m'"," s'")
fix_stop=rep(" ",length(stop_words))
names(fix_stop) <- stop_words

Puis on passe en minuscules, on supprime les stopwords puis les espaces en trop.

data2 <- data2%>%
  mutate(Indicateur=as.character(Indicateur))%>%#passage en char
  mutate_if(is.character,tolower)%>%#en minuscules
  mutate_if(is.character,function(x)str_replace_all(x,fix_stop))%>%#suppression de stopwords génériques et spécifiques
  mutate_if(is.character,tm::stripWhitespace)#suppression des doubles espaces

Suppression des colonnes constantes

cardinality=sapply(data2,function(x)length(unique(x)))
head(cardinality)
##                                             index 
##                                             18885 
##                                              Base 
##                                                25 
##                                        Indicateur 
##                                             18360 
##                                           Famille 
##                                              1933 
##                              Famille Finale_DREES 
##                                                 1 
## Classement producteur Niveau 3 (le plus détaillé) 
##                                               410
data2=data2[,cardinality>1]

Construction du bloc de texte

data2$Indicateur_enriched=paste(data2$Indicateur,
                                data2$Famille,
                                data2$`Classement producteur Niveau 1 (le moins détaillé)`,
                                data2$`Classement producteur Niveau 2`,
                                data2$`Classement producteur Niveau 3 (le plus détaillé)`,
                                data2$source_acronyme,data2$producteur_acronyme)

Longueur du texte :

nchar(data2$Indicateur)%>%hist(main="Distribution du nombre de caractères dans le texte")

On va compter les espaces pour se donner une idée du nombre de mots

str_count(data2$Indicateur," ")%>%hist(main="Distribution du nombre de mots dans le texte")

Les tags

Aperçu

Chaque indicateur taggé par machine learning a ensuite été validé par son producteur qui nous a renvoyé un fichier excel, ce qui fait une trentaine de fichiers Excel homogénéisés et empilés. On sautera cette étape et on travaillera directement sur le fichier intermédiaire : tagged_triplet_agreg.RData

load("tagged_triplet_agreg.RData")

La fameuse liste des tags.

names(tagged)
##  [1] "index"                                                       
##  [2] "Population_generale"                                         
##  [3] "Personnes_agees"                                             
##  [4] "Enfants__adolescents__jeunes_adultes"                        
##  [5] "Population_precaire"                                         
##  [6] "Personnes_handicapees"                                       
##  [7] "Sante_des_femmes_perinatalite"                               
##  [8] "Diabete_et_autres_maladies_endocriniennes"                   
##  [9] "Sante_mentale"                                               
## [10] "Cancer"                                                      
## [11] "Maladie_de_l_appareil_genito_urinaire"                       
## [12] "Maladies_cardiovasculaires"                                  
## [13] "Maladies_neurologiques_ou_degeneratives"                     
## [14] "Maladies_respiratoires"                                      
## [15] "Maladies_de_l_appareil_digestif"                             
## [16] "Maladies_infectieuses"                                       
## [17] "Pathologies_du_systeme_osteo_articulaire"                    
## [18] "Traumatismes_et_pathologies_accidentelles"                   
## [19] "Autres_pathologies"                                          
## [20] "Coordination_continuite"                                     
## [21] "Qualite_et_securite_des_soins"                               
## [22] "Prevention_depistage"                                        
## [23] "Accessibilite_geographique_financier_autres"                 
## [24] "Habitudes_de_vie_et_addictions"                              
## [25] "Determinants_environnementaux"                               
## [26] "E_sante_systemes_d_information"                              
## [27] "Droits_d_usagers_democratie_sanitaire"                       
## [28] "Mesures_d_inegalites_et_de_disparites_territoriales_de_sante"
## [29] "Contexte_demographique_et_socio_economique"                  
## [30] "Offre_de_soins"                                              
## [31] "Offre_medico_sociale"                                        
## [32] "Recours_aux_soins"                                           
## [33] "Protection_sociale"                                          
## [34] "Depenses_de_sante"                                           
## [35] "Etat_de_sante"                                               
## [36] "Determinants_professionnels"
names(tagged) <- tolower(names(tagged))

Pour l’instant on dispose d’un tableau avec une ligne par indicateur et pour chaque colonne un ‘top’ tag ie un booléen qui nous indique si le tag est appliqué.

head(tagged[,1:10])

Nombre de tags par indicateur

Si on aime le jargon ADD (ACM) on peut parler de tableau disjonctif de la variable ‘tag’ à ceci près que plusieurs modalités sont possibles en même temps…

Justement, combien de tags par indicateur ?

rowSums(tagged%>%select(-index))%>%hist

Fréquence des tags

On a donc principalement entre 2 et 4 tags par indicateur.

Maintenant quelle est la fréquence de chaque tag ?

sapply(tagged,mean)[-1]%>%
  data.table(name=names(.),freq=.)%>%{
  ggplot(data=.,aes(x=name,y=freq))+
      geom_bar(stat="identity")+ 
      theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank())}%>%
  ggplotly

Corrélation des tags

On calcule les corrélations entre les tags et on supprime (met à 0) celle inférieure à 10% et celles à 1 qui vont polluer visuellement le graphe.

cor_mat=cor(tagged%>%select(-index))
cor_mat[abs(cor_mat)<.1] <- 0
cor_mat[cor_mat==1] <- 0

Ce package ne gère par les valeurs négatives donc on prendra les valeurs absolues.

chorddiag::chorddiag(abs(cor_mat),showTicks = F,showGroupnames = F)
## Warning in RColorBrewer::brewer.pal(n, palette): n too large, allowed maximum for palette Dark2 is 8
## Returning the palette you asked for with that many colors

Cette information sur la corrélation entre les tags est importante. Elle devra orienter notre choix méthodologique. En effet on ne peut pas considérer que les tags sont indépendants.

Matrice sparse

La densité de la matrice de tags vaut 8.2 %.

On préfère le format triplet qui nous servira ensuite pour une représentation en matrice creuse (sparse)

tagged_triplet=reshape::melt(tagged,id.vars="index")

head(tagged_triplet)

Base indicateurs x tags

Jointure

tagged_triplet=merge(tagged_triplet,data2%>%select(index,Base,Indicateur),by="index") %>% mutate_if(is.factor,as.character)

tagged_triplet %<>% rename(id=index)
tagged_triplet=data.table(tagged_triplet)

Numérotation des lignes

On récupère la liste des tags pour les numéroter.

tags <- unique(tagged_triplet$variable)
tagged_triplet=merge(tagged_triplet,data.frame(tags=tags,tag_id=1:length(tags),stringsAsFactors = F),by.x="variable",by.y="tags")

On numérote les lignes issues du croisement indicateur x tag pour pouvoir ensuite définir manuellement une matrice sparse exploitable par XGBOOST.

tagged_triplet <- tagged_triplet%>%mutate(i=(tag_id-1)*nb_indicateurs+id)#%>%select(-tag_id)

On gère les problèmes de doublons et on récupère les numéros des indicateurs qui ont été taggés, c’est uniquement sur ces indicateurs qu’on pourra entraîner/vérifier le modèle.

tagged_triplet=data.table(tagged_triplet)[,.SD[1],by="i"]
tagged_ids = unique(tagged_triplet$id)

Vectorisation du text avec text2vec

Les tags

On remplace les séparateurs _ par des espaces pour que la fonction reconnaisse les tokens.

Pour les tags on va un peu vite parce qu’il n’y a pas beaucoup d’enjeux, on est sur quelques dizaines de mots, chaque est important. On décide de cette approche parce qu’on pense que le mots “soin”, “offre”, “population”, “maladie”, “pathologie”, etc. qui sont présents dans plusieurs tags, devraient être pris en compte par le modèle.

tags_dtm <- tags%>%
  gsub(pattern = "_",replacement = " ")%>%#conversion _ en " "
  str_replace_all(fix_stop)%>%#suppression des stopwords
  itoken(tolower,word_tokenizer)%>% # extraction des tokens
  {create_dtm( # Création d'un dtm...
    vocab_vectorizer( # A partir de la matrice du texte vectorisé ...
      create_vocabulary(.,ngram=c(1L,3L)) # A partir d'un vocabulaire de 1 grams à 3 grams
    ),it=.)
  }
dimnames(tags_dtm)[[1]] <- tags

Le problème c’est qu’on a créé beaucoup d’hapax ie des façons différentes de représenter le même tag ! On veut supprimer ces doublons.

col_to_rm=c()
for (i in 1:(ncol(tags_dtm)-1)){
  for(j in (i+1):ncol(tags_dtm)){
    if(sum(tags_dtm[,i]==tags_dtm[,j])==nrow(tags_dtm)){
    col_to_rm=c(col_to_rm,j)
    }
  }
}
col_to_rm=sort(unique(col_to_rm))

Chaque tag contient :

  • Une représentation si c’est suffisant (aucun mot partagé avec les autres tags)
  • Plusieurs si certains des mots (ou ngram) sont présents dans d’autre tags
tags_dtm=tags_dtm[,-col_to_rm]
rowSums(tags_dtm)
##                                          population_generale 
##                                                            2 
##                                           autres_pathologies 
##                                                            3 
## mesures_d_inegalites_et_de_disparites_territoriales_de_sante 
##                                                            2 
##                    diabete_et_autres_maladies_endocriniennes 
##                                                            3 
##                        maladie_de_l_appareil_genito_urinaire 
##                                                            2 
##                   contexte_demographique_et_socio_economique 
##                                                            1 
##                              maladies_de_l_appareil_digestif 
##                                                            3 
##                                   maladies_cardiovasculaires 
##                                                            2 
##                                              personnes_agees 
##                                                            2 
##                    traumatismes_et_pathologies_accidentelles 
##                                                            2 
##                                                       cancer 
##                                                            1 
##                         enfants__adolescents__jeunes_adultes 
##                                                            1 
##                                qualite_et_securite_des_soins 
##                                                            2 
##                                         prevention_depistage 
##                                                            1 
##                                            recours_aux_soins 
##                                                            2 
##                                         offre_medico_sociale 
##                                                            3 
##                  accessibilite_geographique_financier_autres 
##                                                            2 
##                                          population_precaire 
##                                                            2 
##                                determinants_environnementaux 
##                                                            2 
##                                                sante_mentale 
##                                                            2 
##                               habitudes_de_vie_et_addictions 
##                                                            1 
##                                        personnes_handicapees 
##                                                            2 
##                                            depenses_de_sante 
##                                                            2 
##                      maladies_neurologiques_ou_degeneratives 
##                                                            2 
##                                        maladies_infectieuses 
##                                                            2 
##                                sante_des_femmes_perinatalite 
##                                                            2 
##                               e_sante_systemes_d_information 
##                                                            2 
##                     pathologies_du_systeme_osteo_articulaire 
##                                                            2 
##                        droits_d_usagers_democratie_sanitaire 
##                                                            1 
##                                                etat_de_sante 
##                                                            2 
##                                               offre_de_soins 
##                                                            3 
##                                  determinants_professionnels 
##                                                            2 
##                                      coordination_continuite 
##                                                            1 
##                                       maladies_respiratoires 
##                                                            2 
##                                           protection_sociale 
##                                                            2

La vision complémentaire : les termes présents dans plusieurs tags

colSums(tags_dtm)%>%sort(decreasing = T)%>%head(10)
##     maladies        sante  pathologies       autres        soins 
##            6            6            3            3            3 
##        offre      sociale     appareil determinants   population 
##            2            2            2            2            2

On garde ces informations sur les tags pour plus tard

tags_corres=data.frame(tags=tags,tag_id=as.numeric(dimnames(tags_dtm)[[1]]))
## Warning in data.frame(tags = tags, tag_id = as.numeric(dimnames(tags_dtm)
## [[1]])): NAs introduits lors de la conversion automatique
i_tags=summary(tags_dtm)$i
j_tags=summary(tags_dtm)$j
dimnm_tags=dimnames(tags_dtm)

Les indicateurs

On commence par appliquer des standardisations avancées au texte : suppression des accents, stemming ou lemmatisation.

Stemming

Si vous voulez tester, vous pouvez reprendre le code du TD text-mining avec le package SnowballC. N’oubliez pas de “remplir” le stem avec stemCompletion du package tm afin d’obtenir un résultat un minimum lisible.

Lemmatisation

On commence par placer le texte dans un vecteur et supprimer les accents.

text <- data2$Indicateur_enriched
text=iconv(text,from="UTF-8",to="ASCII//TRANSLIT")

Pour commencer il faut installer treetagger et ajouter les variables d’environnement pour pouvoir l’appeler en ligne de commande.

On ajoute “azerty” pour servir de séparateur d’indicateursles caractères spéciaux même rares comme | sont déjà présents dans le txt

fwrite(x = list(paste(text,"azerty")),"indicateurs.txt")
readLines("indicateurs.txt",3)
## [1] "montants infra-annuels remboursement soins generalistes - tous risques confondus - serie labellisee date soins soins ville rembourses depenses assurance maladie depenses date soins - series labellisees depenses mensuelles date soins sniiram cnamts azerty"
## [2] "montants infra-annuels remboursement soins specialistes - tous risques confondus - serie labellisee date soins soins ville rembourses depenses assurance maladie depenses date soins - series labellisees depenses mensuelles date soins sniiram cnamts azerty"
## [3] "montants infra-annuels remboursement soins sages femmes - tous risques confondus - serie labellisee date soins soins ville rembourses depenses assurance maladie depenses date soins - series labellisees depenses mensuelles date soins sniiram cnamts azerty"

On lance treeTagger : ça prend 12 secondes sur mon X270. C’est vraiment rapide. SINON si on devait gérer un texte plus long on commencerait par extraire le vocabulaire et on appliquerait treeTagger uniquement sur le vocabulaire pour éviter d’appliquer plusieurs fois les mêmes opérations… ** Au cas où vous auriez des difficultés à installer treeTagger, je vous ai fourni le fichier indicateurs_tagtreed2.txt**

system.time(system("tag-french indicateurs.txt > indicateurs_tagtreed2.txt")) 

On regarde ce que ça donne.

tagged_parsed=fread("indicateurs_tagtreed2.txt",fill=T,header=F)
names(tagged_parsed) <- c("mot_original","type_de_mot","mot_lemme")
head(tagged_parsed,10)
tail(tagged_parsed,10)
tagged_parsed=tagged_parsed[-nrow(tagged_parsed),]# on supprime la dernière ligne, pas besoin du dernier séparateur.

On peut regarder comment les mots ont été taggés (on parle de tags là aussi… attention au risque de confusion)

tagged_parsed[grep("cardio",tagged_parsed$mot_original),]

En investiguant les différents tags on identifie deux tags inutiles relatifs à la ponctuation et aux nombres.

tagged_parsed%>%filter(mot_lemme=="@card@")%>%head
tagged_parsed%>%filter(type_de_mot=="SENT")%>%head

On les supprime :

ajustement_text=tagged_parsed%>%
  filter(!type_de_mot%in%c("PUN","SENT"))%>%
  mutate(text_ajuste=ifelse(type_de_mot=="NUM",mot_original,mot_lemme))

Puis on reconstitue notre vecteur d’indicateurs lemmatisés et nettoyés

big_txt=paste(ajustement_text$text_ajuste,collapse=" ")
split_txt=strsplit(big_txt,split = "azerty")
split_txt=iconv(unlist(split_txt),'UTF-8','latin1')
head(sample(split_txt))
## [1] " depassements chirurgien dentiste liberaux specialises medecine bucco-dentaire actif part entiere ape depassements chirurgien dentiste liberaux professionnel sante liberaux honoraire honoraire|honoraires total moyen snir cnamts "                                                                                                                                                                             
## [2] " nombre consultation visiter sages-femmes liberales actif part entiere sage-femme consultation visiter sages-femmes structure activites soin production soin liberaux acter produire professionnel sante snir cnamts "                                                                                                                                                                                            
## [3] "   nombre personne beneficiaires rsa soumettre droit devoir tranche anciennete rsa moins 6 moi|mois moins 1 an personne beneficiaires rsa soumettre droit devoir selon statut orientation aider action social orientation accompagnement beneficiaires rsa enquete le orientation accompagnement beneficiaires rsa donnees infranationales vague 2015 enquete orientation accompagnement beneficiaires rsa drees "
## [4] "   mco nombre etablissements etablissements mco activite analyser activite statistique groupe diagnostic acte pmsi atih "                                                                                                                                                                                                                                                                                         
## [5] " nombrer total enfant accueillir aider social enfance aider social enfance aider action social le beneficiaires aider social departementale aider social enfance enquete aider social drees "                                                                                                                                                                                                                     
## [6] " nombre acte psy realises patient territoire sante acte psychiatrie activite consommation production soin analyser croisee consommation/production soin rim-p atih "

Comme précédent on génère le vocabulaire sur les n-grams 1-3 avec les fonctions de text2vec

tokens = word_tokenizer(split_txt)
it = itoken(tokens, progressbar = FALSE)
vocab = create_vocabulary(it, ngram = c(1L, 3L))
vocab_init=nrow(vocab)
vocab = prune_vocabulary(vocab, term_count_min = 3L)
vocab_pruned_freq=nrow(vocab)

On est très léger sur le filtrage du vocabulaire, on a seulement supprimé les termes présents moins de 3 fois… On est parti d’un vocabulaire de taille 68422 pour arriver à un vocabulaire de taille 31114.

On jongle entre les formats de matrices creuses, essayez de comprendre ce qui diffère entre les diverses représentations dgTMatrix, dgCMatrix, ngCMatrix…

vectorizer = vocab_vectorizer(vocab)
dtm=create_dtm(it,vectorizer,type = "dgCMatrix")
dtm=as(dtm, "ngCMatrix")

Finalement on récupère les informations qui nous intéressent pour construire par la suite une matrice sparse dans un autre format, celui ingéré par xgboost.

i=summary(dtm)$i
j=summary(dtm)$j
dimnm=dimnames(dtm)

Les notions

Aperçu

Avec des experts médicaux on a construit une liste de synonymes ou notions clefs qui permettent d’attribuer un tag à un indicateur. On va utiliser cette liste pour gérer le tagging des cas triviaux.

notions <- readxl::read_xlsx("20180426_Dictionnaire des notions edited.xlsx")
names(notions) <- tolower(names(notions))
names(notions)[!names(notions)%in%tags]
## character(0)

On empile les colonnes et on traite le texte (passage en lettres minuscules)

notions <- lapply(1:ncol(notions),function(i){
  data.frame(notion=names(notions)[i],termes=unname(notions[,i]))%>%
    na.omit%>%
    mutate_all(as.character)
}
)%>%
  do.call(what = "rbind")%>%
  mutate(termes=tolower(termes))

head(notions)
nrow(notions)
## [1] 345

On supprime les accents et on lemmatise

notions_txt=notions$termes
notions_txt=iconv(notions_txt,from="UTF-8",to="ASCII//TRANSLIT")
fwrite(x = list(paste(notions_txt,"azerty")),"notions_2B_lem.txt")
readLines("notions_2B_lem.txt",10,encoding = "utf8")
system.time(notions_lemmed <- system("tag-french notions_2B_lem.txt",intern = T))
fwrite(list(notions_lemmed),"notions_lemmatized.txt")

On effectue les mêmes traitements que précédemment : on supprime les ponctuations et nombres… et on reconstruit le vecteur de texte.

Attention, il est nécessaire d’appliquer strictement les mêmes transformations sur le texte des indicateurs et le texte des notions afin de pouvoir apparier (grep) les deux.

Encore une fois, si treeTagger ne fonctionne pas sur votre poste, il vous suffit de récupérer notions_lemmatized.txt.

notions_lemmatized=fread(input = "notions_lemmatized.txt",sep="\t",fill=T,header=F)
names(notions_lemmatized) <- c("mot_original","type_de_mot","mot_lemme")
notions_lemmatized=notions_lemmatized[1:(nrow(notions_lemmatized)-4)]
notions_lemmatized=notions_lemmatized%>%
  filter(!type_de_mot%in%c("PUN","SENT"))%>%
  mutate(text_ajuste=ifelse(type_de_mot=="NUM",mot_original,mot_lemme))
notions_lemmatized=paste(notions_lemmatized$text_ajuste,collapse=" ")
stringr::str_count(notions_lemmatized,"azerty")
## [1] 344
notions_lemmatized=strsplit(notions_lemmatized,split = "azerty")[[1]]
sum(stringr::str_count(notions_lemmatized,"azerty"))
## [1] 0
head(notions_lemmatized)
## [1] "addiction "                                                                            
## [2] " centrer accueil et accompagnement avoir le reduction de risque pour usager de drogue "
## [3] " contraception "                                                                       
## [4] " depistage "                                                                           
## [5] " education "                                                                           
## [6] " mst "
notions_lemmatized=tm::stripWhitespace(notions_lemmatized)
notions_lemmatized=gsub("^ ","",notions_lemmatized)
notions_lemmatized=gsub(" $","",notions_lemmatized)
length(notions_lemmatized)==nrow(notions)
## [1] TRUE
notions$termes=notions_lemmatized
notions=unique(notions)

Matching avec les indicateurs

On va construire une variable (qui sera la dernière variable du tableau, après la vectorisation du texte) à partir des notions qui nous indique si l’un des termes relatifs à un tag est présent pour un indicateur. La fonction centrale est str_which.

notions$tag_id=sapply(notions$notion,function(x)which(tags==x))
nb_ngram_indic=max(j)
nb_features=max(j)+max(j_tags)

system.time(match_notions_indic <- do.call("rbind",pbapply::pbsapply(1:nrow(notions),
         function(index){
           matching=str_which(pattern = paste0("(^|( ))(",notions$termes[index],")(( )|($))"),
                              string = split_txt)#text
           if(length(matching)>0){
             data.frame(i= matching,
                        tag_id=notions$tag_id[index],
                        j=nb_features+1,notion=notions$termes[index], stringsAsFactors = F)
           } else NULL
         }
)))
##    user  system elapsed 
##   34.78    0.85   36.02
head(match_notions_indic)
  • i => ligne = numéro de l’indicateur récup avec split_txt
  • j => colonne = numéro du token dans la sparse matrix
  • tag_id => tag associé
  • N’oubliez pas qu’on fera un modèle binomial ie indicateur x tag = TRUE/FALSE

Pertinence des notions

tags_ok=tagged_triplet
tags_ok=merge(match_notions_indic,tags_ok,by.x=c("i","tag_id"),by.y=c("id","tag_id"),all.y=T)

table(!is.na(tags_ok$j)# On a fait une jointure à droite donc !is.na signifie qu'il y a eu matching notion <-> indicateur
      ,tags_ok$value # 1 = tag ok pour cet indic, 0 = tag ko pour cet indic
      )
##        
##              0      1
##   FALSE 190012  13991
##   TRUE    2085   3618

Plus précisément, investiguons les termes problématiques.

table(tags_ok$notion# les notions qui génèrent le tagging automatique
      ,tags_ok$value # 1 = tag ok pour cet indic, 0 = tag ko pour cet indic
      )
##                               
##                                  0   1
##   accident                      47  74
##   accouchement                   2  50
##   addiction                      3   4
##   adenome                        0   8
##   adolescent                     0  58
##   agees                         13  76
##   amygdalectomie                 0   2
##   appendicectomie                0   3
##   asthme                         2   1
##   biologie medicale              2   7
##   bronchite                      0   2
##   brulure                        0   5
##   cancer                         3 824
##   cancerologie                   0  23
##   cannabis                      86   0
##   cardiaque                      0   9
##   cataracte                      0   2
##   chimiotherapie                 0  33
##   chirurgie generale             3   0
##   chirurgie testiculaire         1   1
##   chirurgie vasculaire           0   2
##   cholecystectomie               0   2
##   clic                           1   0
##   cmu                            5   0
##   cmuc                          12   5
##   cognitif                       5   0
##   coloscopie                     0  34
##   contraception                  1   1
##   coordination                   0   5
##   dent                           1   2
##   dentaire                       1  26
##   dentiste                       2  46
##   depistage                      0 210
##   dialyser                       0  10
##   digestif                      78  86
##   droguer                       10   4
##   ecg                            2   0
##   education                      8   4
##   endoscopie digestif            0   3
##   enfant                        21 114
##   epaule                         0   3
##   epilepsie                      0  13
##   feminin                        0   4
##   feminine                       0   2
##   femme                         11 248
##   fondre aide                    2   0
##   fragilite economique           7   0
##   fragilite socio                0   2
##   genou                          2   8
##   glycemie                       2   0
##   grossesse                      3  29
##   gynecologue                    3   2
##   hancher                        0   5
##   handicap                       3  16
##   handicapees                   10  12
##   handicaper                    19  35
##   hebergement social             2   1
##   hemodialyse                    0  10
##   hepatite                       1   1
##   hepatologie                    0   3
##   hypertension                   0   6
##   incapacite                     5   0
##   infarctus                      0   9
##   insuffisance cardiaque         0   1
##   insuline                       0   8
##   invalide                       0   4
##   invalidite                     6  21
##   ipp                            1   0
##   jeune                          4  20
##   kinesitherapeutes              9   9
##   main                           0   2
##   maladie alzheimer              4   2
##   masseur                        1   1
##   mdph                           3   0
##   medecine genetique             0   2
##   medecine interne               4   0
##   medecine nucleaire             1   1
##   migrainer                      0   3
##   mineur                         0   4
##   nerveux                       47   5
##   neurochirurgie                 0   2
##   non programmer                 1   0
##   obesite                        3   0
##   ophtalmologie                  0   3
##   ophtalmologue                  2  13
##   orientation                    0   2
##   orthophoniste                  1  17
##   parcourir                      1  15
##   perinatale                     4  79
##   pertinence                     0   3
##   pneumologie                    0   3
##   pneumonie                      0   1
##   poignet                        0   2
##   polyarthrite rhumatoide        0   2
##   poumon                         2  43
##   prado                          0  12
##   premature                      3   0
##   prevention                   332  86
##   prostatectomie transuretrale   0   3
##   prothese dentaire              0   4
##   psy                           13 254
##   psychiatrie                   11 315
##   psychiatrique                  8  24
##   psychique                      0   9
##   psychoactives                437  14
##   psychologique                  1   2
##   psychotrope                   91  31
##   radiodiagnostic                0   1
##   radiophysiciens                0   1
##   radiotherapie                125   4
##   reanimation medicale           0   3
##   rectocolite                    0   1
##   rehospitalisation              4   2
##   rhumatologie                   0   3
##   rhumatologue                   0   2
##   rougeole                       0   3
##   rsa                            0   6
##   sante mental                   4  34
##   satisfaction                   0   1
##   securite                       7   8
##   sevrage                        0   4
##   sida                           1  26
##   specialistes                 112  53
##   stomatologie                   0   8
##   substance                    439  14
##   suicider                       2  26
##   test positif                   0   6
##   testiculaire                   1   1
##   thyroide                       7  19
##   trachee                        1   7
##   trouble mental                 7 105
##   tuberculose                    0   3
##   tumeur                         1  75
##   vaccin                         0   2
##   vaccination                    0   7
##   vieillesse                     5   2
##   vih                            0  24

psychoactives, cannabis, radiothérapie sont des “notions” proposées par des experts mais “refusées”" par d’autres qui effectuent le tagging manuel. On en reste là pour l’analyse de la cohérence des notions, on va passer à la suite mais d’abord…

On supprime les doublons.

match_notions_indic=unique(match_notions_indic[,c("i","tag_id","j")])

Agrégation

Ce qui peut sembler surprenant jusque là c’est qu’on a construit une grosse dtm avec tout le vocabulaire sur les indicateurs, mais pour l’apprentissage on pourra se servir uniquement du vocabulaire observé dans les indicateurs taggés !

La motivation est de pouvoir rapidement intégrer les éléments de vocabulaires lorsqu’un nouvel indicateur est taggé, on aura besoin de cette flexibilité pour réaliser l’active learning.

Préparation des objets à agréger

On utilise expand.grid pour produire la table de croisement indicateurs x tags. Vous avez probablement déjà utilisé expand.grid pour réaliser des grid-search dans les cours de machine learning.

nb_ngram_indic <- max(j)
match_notions_indic <- match_notions_indic%>%mutate(id=(tag_id-1)*nb_indicateurs+i)%>%select(-i,-tag_id)
# tags_corres=data.frame(tags=tags,tag_id=1:length(tags))

i2 <- expand.grid(tag_id=1:length(tags),ind_id=i)%>%
  mutate(id=(tag_id-1)*nb_indicateurs+ind_id)%>%.$id
j2 <- expand.grid(tag_id=1:length(tags),j=j)%>%.$j
length(text)==nb_indicateurs
## [1] TRUE
i_tags2 <- expand.grid(tag_id=i_tags,ind_id=1:length(text))%>%mutate(id=(tag_id-1)*nb_indicateurs+ind_id)%>%.$id
j_tags2 <- expand.grid(j_tags=j_tags,ind_id=1:length(text))%>%.$j_tags

j_tags2 <- j_tags2+nb_ngram_indic

i_dimname <- data.frame(i2)%>%distinct%>%.$i2

On vérifie la cohérence. Si tout est à 0 c’est que ça fonctionne

sum(!(unique(i_tags2)%in%i_dimname))
## [1] 0
sum(!(unique(match_notions_indic$id)%in%i_dimname))
## [1] 0
sum(!(unique(i2)%in%i_dimname))
## [1] 0

Génération de la matrice creuse

Et on génère la matrice sparse avec la fonction du package Matrix.

dtm_sp <- sparseMatrix(i=c(i2,i_tags2,
                           match_notions_indic$id),
                       j=c(j2,j_tags2,match_notions_indic$j),
                       dimnames = list(1:max(i_dimname)%>%as.character,
                                       c(dimnm[[2]],
                                         paste0("__",dimnm_tags[[2]]),
                                         "notions")))

Taille des objets

On compare la taille des différents objets

object.size(dtm_sp)
## 220981736 bytes
object.size(i2)+object.size(i_tags2)+object.size(match_notions_indic$id)
## 351964864 bytes
object.size(j2)+object.size(j_tags2)+object.size(match_notions_indic$j)
## 176034168 bytes
object.size(list(1:max(i_dimname)%>%as.character,
              c(dimnm[[2]],paste0("__",dimnm_tags[[2]]),"notions")))
## 44873456 bytes

Vérifications

On tire un indicateur au hasard et on vérifie sa cohérence.

Pour commencer on vérifie si le tag et l’indicateur sont placés tel qu’on l’a imaginé et si les ngrams sont cohérents.

index_test=sample(max(i2),1)
data2[data2$index==index_test%%nb_indicateurs,]$Indicateur
## [1] "taux attractivité global séjours complatih"
tags[(index_test-1)%/%nb_indicateurs+1]# le tag associé
## [1] "qualite_et_securite_des_soins"
i_variantes=as.character(0:(length(tags)-1)*nb_indicateurs+index_test%%nb_indicateurs)
i_variantes%in%dimnames(dtm_sp)[[1]]#ces index existent-ils dans la dtm ?
##  [1] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [15] TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE TRUE
## [29] TRUE TRUE TRUE TRUE TRUE TRUE TRUE
ngrams=dtm_sp[index_test,]
ngrams=names(ngrams[ngrams])
ngrams # les ngrams de l'indicateur x tag
##  [1] "attractivite_global"      "taux_attractivite_global"
##  [3] "sejours_complatih"        "sejours_complatih_ssr"   
##  [5] "complatih_ssr"            "complatih_ssr_tau"       
##  [7] "complatih"                "taux_pmsi"               
##  [9] "tau_taux_pmsi"            "taux_pmsi_atih"          
## [11] "ssr_tau_taux"             "ssr_tau"                 
## [13] "taux_attractivite"        "tau_taux_attractivite"   
## [15] "attractivite"             "global"                  
## [17] "ssr"                      "sejours"                 
## [19] "pmsi_atih"                "pmsi"                    
## [21] "atih"                     "tau_taux"                
## [23] "tau"                      "taux"                    
## [25] "__qualite_securite"       "__soins"

Ensuite on vérifie les notions présentes dans cet indicateur

dtm_sp[index_test,"notions"]
## [1] FALSE
dtm_sp[i_variantes,"notions"]
##  13952  32837  51722  70607  89492 108377 127262 146147 165032 183917 
##  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE 
## 202802 221687 240572 259457 278342 297227 316112 334997 353882 372767 
##  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE 
## 391652 410537 429422 448307 467192 486077 504962 523847 542732 561617 
##  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE  FALSE 
## 580502 599387 618272 637157 656042 
##  FALSE  FALSE  FALSE  FALSE  FALSE
data2[data2$index==index_test%%nb_indicateurs,]$Indicateur
## [1] "taux attractivité global séjours complatih"
tags[dtm_sp[i_variantes,"notions"]]
## character(0)

Machine Learning

Préparation

Echantillonnage train-test

On échantillonne sur les indicateurs et non directement sur les couples indicateurs x tags.

train_smp=sample(tagged_ids,size = round(.75*length(tagged_ids)))
test_smp = setdiff(tagged_ids, train_smp)
train_ind=rowSums(expand.grid((1:length(tags)-1)*nb_indicateurs,train_smp))
test_ind=rowSums(expand.grid((1:length(tags)-1)*nb_indicateurs,test_smp))

Bases de train-test

On va sélectionner uniquement les colonnes pertinentes pour l’apprentissage pour ça on a recours à colSums pour vérifier si les colonnes sont constantes égales à 0.

Remarque : Cette pratique nous donne une piste pour l’active learning, on pourra sélectionner les indicateurs les moins bien représentés par le vocabulaire actuellement taggé

ngrams_tagged <- which(colSums(dtm_sp[c(train_ind,test_ind),])>0)
  knowns_ind <- tagged_triplet[tagged_triplet$id%in%train_ind,][['i']] 
  train_ind <- train_ind[train_ind%in%knowns_ind]
  train_ind <- sort(train_ind)
  train_labels <- tagged_triplet[tagged_triplet$id%in%train_ind,]%>%
    arrange(i)%>%.[['value']]
  train_dtm <- dtm_sp[train_ind,ngrams_tagged]
  dtrain <- xgb.DMatrix(data = as(train_dtm,"dgCMatrix"), 
                        label = train_labels)
  ## Même chose pour le test qui va aussi nous servir de validation ici parce qu'on ne fait pas de gridsearch.
  knowns_ind <- tagged_triplet[tagged_triplet$id%in%test_ind,][['i']] 
  test_ind <- test_ind[test_ind%in%knowns_ind]
  test_ind <- sort(test_ind)
  test_labels <- tagged_triplet[tagged_triplet$id%in%test_ind,]%>%
    arrange(i)%>%.[['value']]
  test_dtm <- dtm_sp[test_ind,ngrams_tagged]
  dtest <- xgb.DMatrix(data = as(test_dtm,"dgCMatrix"), 
                        label = test_labels)
  watchlist <- list(train = dtrain,eval = dtest)

Entraînement

On propose deux stratégies d’apprentissage, la première robuste et lente pour le modèle final, la seconde rapide et “suffisante” pour de l’active learning.

timing="fast"
if (timing=="slow"){
params=list(eta=.1,
            max_depth=6,
            min_child_weight=5,
            subsample=500*length(tags)/length(train_ind),
            colsample_bytree=8000/length(ngrams_tagged),
            objective="binary:logistic",
            eval_metric="auc",
            gamma=.01)
nrounds=5E+3
} else if (timing=="fast"){
  params=list(eta=.2,
              max_depth=8,
              min_child_weight=1,
              subsample=500*length(tags)/length(train_ind),
              colsample_bytree=300/length(ngrams_tagged),
              objective="binary:logistic",
              eval_metric="auc",
              gamma=.01)
  nrounds=1E+3
}

On lance xgboost

system.time(xgbmodel <- xgb.train(params = params,dtrain,
                                  verbose = 1,print_every_n = 10,
                                  nrounds = nrounds,watchlist,
                                  early_stopping_rounds=200))
save(xgbmodel,file="trained_model.RData")
load("trained_model.RData")

Analyse des résultats

Importance des variables (ngrams)

Les ngrams précédés de __ sont ceux relatifs aux tags.

Le feature notions est la variable générée à partir du dictionnaire des notions. Elle devrait fonctionner à tous les coups mais on a vu que ce n’est pas toujours le cas.

  • Gain contribution of each feature to the model. For boosted tree model, each gain of each feature of each tree is taken into account, then average per feature to give a vision of the entire model. Highest percentage means important feature to predict the label used for the training (only available for tree models);

  • Cover metric of the number of observation related to this feature (only available for tree models);

  • Weight percentage representing the relative number of times a feature have been taken into trees.

imp=xgb.importance(feature_names = NULL,xgbmodel)
head(imp,100)

Ngrams les plus importants par indicateur

get_imp_ngrams=data.table(i=i,j=j)
dico_ngrams=data.frame(j=1:max(j),ngram=dimnm[[2]])
get_imp_ngrams=merge(get_imp_ngrams,dico_ngrams,by="j")

get_imp_ngrams=merge(get_imp_ngrams,imp,by.x="ngram",by.y="Feature")

setorder(get_imp_ngrams,-Gain)
get_imp_ngrams[,order:=1:.N,by="i"]
get_imp_ngrams=get_imp_ngrams[order<=10]

get_imp_ngrams=dcast(get_imp_ngrams,i~order,value.var="ngram")

get_imp_ngrams=merge(get_imp_ngrams,data2[,c("index","Indicateur")],by.x="i",by.y="index")

sample_n(get_imp_ngrams%>%select(-i),10)

On remarque que des stopwords nous ont échappé… mais manifestement ils n’étaient pas si “creux” puisque le modèle les a retenu.

Si on voit les choses autrement, on peut se dire que lorsque le ngram influent est un stopwords, les autres ngrams moins influents ne sont probablement pas pertinent. De plus si LE ngram le plus influent est un stopword, alors l’indicateur est probablement mal taggé…

Prédiction

Active Learning